;;;;;
;; pick-belief-*
;;
;; beliefs are chosen from the selected world and any worlds that it
;; imports. in general, the system will not choose to explain nested
;; beliefs unless directed to do so as a result of planning or problem
;; solving.

;;; returns the most recently believed belief in the list.
;;; maximizes belief-start.
(defun get-newest (wbs)
  (loop with newest = (first wbs)
     for wb in (rest wbs)
     when (> (belief-start (second wb)) (belief-start (second newest)))
     do (setf newest wb)
     finally (return newest)))

(defun get-agent-beliefs (world)
  (funcall #'append 
	   (get-local-beliefs world) 
	   (get-observed-beliefs world)
	   (get-goals world)
	   (get-intentions world)))

;; selects a random belief that's visible from the given world. if no
;; world is given, assume the primary system world. 
(defun pick-belief-random (wm &key (world (wm-prime wm)))
  (let ((blfs (get-agent-beliefs world)))
    (nth (random (length blfs)) blfs)))

;; selects the most recent belief. if world is specified, then limits
;; its search to beliefs viewable from that world.
(defun pick-belief-recency (wm &key (world (wm-prime wm)))
  (get-newest  (get-agent-beliefs world)))


;; returns the belief that can be explained by the fewest possible
;; rules.  favors making obvious inferences so that later inferences
;; so that we can use the new information to guide other inferences.
(defun get-fewest-rules (wbs)
  (when wbs
    (let* ((fewest (first wbs))
	   (fewest-score (length (get-rules (second fewest) kb)))
	   (tmp-score))
      (dolist (wb (rest wbs) (when (> fewest-score 0) fewest))
	(setf tmp-score (length (get-rules (second wb) kb)))
	(when (and (> tmp-score 0) 
		   (< tmp-score fewest-score))
	  (setf fewest wb)
	  (setf fewest-score tmp-score))))))



(defun pick-belief-fewrules (wm &key (world (wm-prime wm)))
  (get-fewest-rules (get-agent-beliefs world)))

;; turns out that this approach is related to earlier work on
;; "essential explanations" see -- Olivier Fischer, Ashok Goel, John
;; R. Svirbely, Jack W. Smith, The role of essential explanation in
;; abduction, Artificial Intelligence in Medicine, Volume 3, Issue 4,
;; August 1991, Pages 181-191, ISSN 0933-3657, DOI:
;; 10.1016/0933-3657(91)90010-9.
(defun pick-belief-fewrules-unattached (wm &key (world (wm-prime wm)))
  (or 
   (get-fewest-rules (delete-if-not #'(lambda (x)
				    (when x
				      (let ((b (second x)))
					(and (null (get-support b world))
					     (null (belief-weak-links b))
					     (get-rules b kb)))))
				(get-agent-beliefs world)))
   (pick-belief-random wm :world world)))

;;; returns the most recent unexplained belief or the most recent belief if
;;; everything's been explained.
;;; HMM: predicates that cannot be explained given the current rule set
;;;      (e.g., (name bill2 bill)) can block progress. we could "dirty" 
;;;      the beliefs, but the current (easy) fix is to ignore beliefs that
;;;      can't be worked into the explanation.
(defun pick-belief-recency-unattached (wm &key (world (wm-prime wm)))
  (or 
   (get-newest (delete-if-not #'(lambda (x)
			      (when x
				(let ((b (second x)))
				  (and (null (get-support b world))
				       (null (belief-weak-links b))
				       (gethash (predicate-name (belief-content b)) 
						(if (negated? (belief-content b))
						    (kb-neg-cpt kb)
						    (kb-pos-cpt kb)))))))
			  (get-agent-beliefs world)))
   (pick-belief-recency wm :world world)))



(defun get-inst-rules (lit kb)
  (mapcar #'(lambda (x)  
	      ;; (instantiate-rule x)))
	      (gethash x (kb-rl-to-jst kb))) ;; cached
	  (gethash (predicate-name lit) 
		   (if (negated? lit)
		       (kb-neg-cpt kb)
		       (kb-pos-cpt kb)))))

;;;;;
;; old-plan-abd
;; 
;; the first stage in the plan-generate-test approach.
;;
;; * plan - applies cheap constraints that don't require binding the
;;   rule to a belief. this could be something like "if there's
;;   already an explanation for the belief, use that. the heuristics
;;   here can be just as flexible as anywhere else. this gets and
;;   analyzes the belief, the current applicable justifications, and
;;   the applicable rules and prunes a bit.
;;
;; options: 
;;   bc-only? - when true, will enforce inferences from the consequent
;;              only. if the consequent is a conjunction, only requires
;;              one member to fire the rule. we can later add a means
;;              to require multiple members.
;;
;;   focused? - when true, automatically prefers existing
;;              justifications over new ones. importantly, if a belief
;;              is already explained by a rule, then that
;;              justification will be selected, and no alternatives
;;              will be explored (unless randomization is used).
;;
;;   random? - when true, a single rule/justification will be selected
;;             uniformly at random. if focused? is true, then there is
;;             a fifty-percent chance that the result will be a new
;;             rule even when there is an existing justification.
(defun old-plan-abd (b wrld wm kb 
		     &key (bc-only? nil) (focused? nil) (random? nil))
  (let ((joptions (get-justifications wrld)) ;; existing justifications in wrld
	(roptions (get-inst-rules (belief-content b) kb))
	(spoptions))

    ;; a justification may have variable bindings that conflict with
    ;; the belief. if so, then we need to toss it out.
    ;; also, rules and justifications may not match based on the
    ;; modality of the predicate, so we need to check for that.
    (setq joptions (delete-if #'(lambda (j) (not (bindable? b j wrld)))
			      joptions))

    (setq roptions (delete-if #'(lambda (r) (not (bindable? b r wrld)))
			      roptions))

    ;; combine the two lists depending on how conservative we want the
    ;; system to be.
    (unless (and focused? joptions)
      (setq joptions (append roptions joptions)))

    ;; we could add any number of optional constraints to apply at
    ;; this point. each one would serve to reduce the work required
    ;; during the candidate generation phase.

    ;; drop rules unless the belief predicate appears in the
    ;; head. (back chain abduction only)
    (when bc-only?
      (setq joptions (delete-if-not #'(lambda (rl) (in-consequent? b rl wrld))
				    joptions)))

    ;; inject a bit of randomness if you're brave.
    (mapcar #'(lambda (j) (make-candidate :original-justification j 
					  :original-belief b
					  :world wrld))
	    (if random?
		(if (and focused? roptions (= (random 2) 0))
		    (list (nth (random (length roptions)) roptions))
		    (when joptions
		      (list (nth (random (length joptions)) joptions))))
		joptions))))


;;;;;
;; plan-abd
;; 
;; the first stage in the plan-generate-test approach.
;;
;; * plan - applies cheap constraints that don't require binding the
;;   rule to a belief. this could be something like "if there's
;;   already an explanation for the belief, use that. the heuristics
;;   here can be just as flexible as anywhere else. this gets and
;;   analyzes the belief, the current applicable justifications, and
;;   the applicable rules and prunes a bit.
;;
;; options: 
;;   lookahead? - when true, uses heuristic search to find justifications
;;                that are on the path of connecting the focus to the
;;                larger collection of beliefs in working memory.
;;
;;                when false, see old-plan-abd.
;;
;; returns a list of candidates
(defun plan-abd (b wrld wm kb 
		 ;; none of these keywords are relevant in the new version
		 ;; we'll probably want different keywords
		 &key (lookahead? t) (bc-only? nil) (focused? nil) (random? nil))
  (if lookahead?
      (mapc #'(lambda (cj) 
		(setf (candidate-original-belief cj) b)
		(setf (candidate-world cj) wrld))
	    (pick-candidates (belief-content b) wrld wm kb))
      (old-plan-abd b wrld wm kb :bc-only? bc-only? :focused? focused? :random? random?)))

;;;;;
;; existing-justifications
;;
;; TODO: the behavior of this function is experimental. once worlds
;; can import and override each other, it's unclear what it means to
;; collect the existing justifications. we're taking a conservative
;; view first by searching the direct path from the given world to the
;; given belief. later we may want to find all justifications for a
;; belief, or we may want to do some complex interpretation of the
;; import graph. END.
;;
;; returns all justifications on the path between b and wrld that
;; could explain b.
(defun existing-justifications (b wrld wm)
  
;; (get-support (belief-id b) wrld)

  (mappend #'(lambda (x) (get-justifications (predicate-name (belief-content b))
					     (negated? (belief-content b))
					     wrld))
	   (import-path wrld (belief-home b wm))))

;;;;;
;; generate-abduction
;; 
;; the second stage in the plan-generate-test approach.
;;
;;   * generate - carries out the bindings and can produce rules
;;     either by binding the individual belief to each candidate
;;     or by attempting to further specialize those candidates
;;     with the most specific beliefs.  (or possibly both)
;; 
;; takes a list of candidate rules/justifications as input and
;; specializes these to create a larger set of candidates.
(defun generate-abd (b wrld wm kb cands)
  ;; there are two options that we initially want to support 
  ;;
  ;;  * return the candidate justifications bound to the belief
  ;;  * return the candidates bound to the belief, and if more
  ;;    specific beliefs could appear in the rules, try binding to
  ;;    those as well.
  ;; 
  ;; for now, well just do the former because the latter option
  ;; considerably extends the search space.
  
  ;; in addition to each justification, if binding the belief to a
  ;; justification altered the belief's content (replaced skolems),
  ;; then we want to return the original belief so that the system
  ;; knows that it has been superceded (and should probably be
  ;; unbelieved, although that's not entirely necessary).
    
  ;; get rid of justifications that contain X and (not X), we'll
  ;; need to make this time aware when we reason about actions.
  (delete-if #'(lambda (c) (contradictory-justification (candidate-justification c)))
	     (mappend #'(lambda (c) 
			  (mapcar #'(lambda (j) 
				      (setf (candidate-world c) (third j)
					    (candidate-belief c) (second j)
					    (candidate-justification c) (first j))
				      c)
				  (bind-justification (candidate-original-justification c) b wrld wm)))
		      cands)))


;;;;;
;; test-abduction
;;
;; the third stage in the plan-generate-test approach.
;;
;;   * test - evalutes each candidate and selects the one that is
;;     the most promising.
(defun test-abd (b wrld wm cands)
  (dolist (c cands cands)
    (setf (candidate-score c) 
	  (score-justification (candidate-justification c) wrld wm :cost 1))))

(defun display-justifications (wrld)
  (dolist (j 
	    (sort (mapcar #'(lambda (j) (cons (score-justification j wrld wm) j)) 
			  (get-justifications wrld))
		  #'< :key #'car))
    (format t "~A: ~A~%" (car j) (cdr j))))

(defun display-beliefs (wrld)
    (dolist (b (sort (mapcar #'(lambda (wb)
				 (cons (length (get-support (second wb) wrld)) (second wb)))
			     (get-local-beliefs wrld))
		     #'< :key #'car))
      (format t "~A: ~A~%" (car b) (cdr b))))

;; the justification gains points for using beliefs that are supported
;; by other existing justifications. when cost is greater than zero,
;; justifications are penalized by the number of new assumptions they
;; make (cost is uniformly applied to all assumptions).
#|
(defun score-justification (j wrld wm &key (cost 0))
  (let ((score 0) b (nass 0) old-skolems new-skolems nsk)
    (dolist (lit (justification-literals j))
      (setf b (find-belief lit wrld wm))
      (if b
	  (progn 
	    (incf score (score-belief (second b) (first b) wrld))
	    (append (remove-if-not #'skolem? lit) old-skolems))
	  (progn 
	    (incf nass)
	    (append (remove-if-not #'skolem? lit) new-skolems))))
    ;; number of skolems introduced by the justification
    (setf nsk (length (set-difference new-skolems old-skolems)))
    ;; for now, subtract the number of assumptions weighted by some cost measure.
    (- score (* nass cost))))
    ;; (- score (* nsk cost))))
|#

;;; TEST: using an average instead of a sum to reduce the influence of rule length.
;;; don't count found beliefs in the ignore list
(defun score-justification (j wrld wm &key (cost 0) (ignore nil))
  (let ((score 0) b)
    (dolist (lit (justification-literals j) 
	     (/ score (length (justification-literals j))))
      (setf b (find-belief lit wrld wm))
      (when (and b (not (find (belief-content (second b)) ignore :test #'equal))) 
	(incf score (score-belief (second b) (first b) wrld))))))

(defun score-belief (b bwrld jwrld)
  (if (eql bwrld jwrld)
      ;; belief and justification are in the same world, so return the local score
      (length (remove-duplicates (get-support b bwrld)))
      ;; justification is in a different world, so report the normal
      ;; score for the belief in its own world plus any extra support
      ;; it has in jwrld
      (+ 
       (if (member bwrld (world-obs-worlds jwrld) :key #'second) 1 0) ; a point for being an observation
       (length (remove-duplicates (get-support b bwrld))) ; points for local support in bwrld
       ;; points for other connections to jworld
       (count-if #'(lambda (x) (eql (first x) jwrld)) (belief-weak-links b))))) 

;;;;;
;; select-abduction
;;
;; input: cands - a list of scored candidates
;;        selector - a function to select among the candidates
;;        probability - a probability
;;
;; output: a candidate explanation
;; 
;; the explanation is chosen based on the selector function. if
;; probability is greater than zero, then there is a chance
;; (corresponding to the probability) that a random candidate will be
;; selected instead.
(defun select-abd (cands 
		   &key (selector #'high-score-elt) (probability -1.0))
  ;; (print cands)
  ;; (print "-------------------------")
  (if (and (> probability 0.0) (< (random 1.0) probability))
      (random-elt cands)
      (funcall selector cands)))

;;;;;
;; random-elt
;;
;; input: a list
;; output: a random element from that list
(defun random-elt (lst)
  (when lst (nth (random (length lst)) lst)))

;;;;;
;; trim-candidates
;;
;; input: a list of candidates sorted by their scores.
;;        the threshold for keeping a candidate.
;; output: a list of candidates whose scores are higher than
;;         the threshold.
(defun trim-candidates (lst scr scrf)
  (cond ((null lst) nil)
	((< (funcall scrf (car lst)) scr) nil)
	(t (cons (car lst) (trim-candidates (cdr lst) scr scrf)))))

;;;;;
;; high-score-elt (selector)
;; 
;; input: a list of candidates
;; output: the candidate with the highest score. picks randomly
;;         from the list of candidates with the highest score.
(defun high-score-elt (lst)
  (when lst
    (let (slst)
      (setf slst (sort (copy-list lst) #'> :key #'candidate-score))
      (setf slst (trim-candidates slst (candidate-score (car slst)) #'candidate-score))
      ;; resort to lookahead score when there's a tie.
      (when (second slst) 
	(setf slst (sort (copy-list slst) #'> :key #'candidate-la-score))
	(setf slst (trim-candidates slst (candidate-la-score (car slst)) #'candidate-la-score)))
      ;; if all else fails, go random.
      (random-elt slst))))

;;;;; 
;; high-score-new (selector)
;;
;; input: a list of candidates
;; output: the candidate with the highest score that (a) is not already 
;;         explaining the belief and (b) does not generalize an existing
;;         explanation of the belief.
(defun high-score-new (lst)
  (when lst
    (let ((slst (sort (copy-list lst) #'> :key #'candidate-score)))
      (loop for c in slst 
	 when (or (eql 'JNEW (justification-id (candidate-justification c)))
		  (find-if-not #'literal-grounded? (justification-literals (candidate-justification c))))
	 return c))))


;;;;;
;; print-candidate
;;
;; print a candidate in a way that's suitable for debugging.
(defun print-candidate (c str d)
  (format str "~%Candidate ::~%~TScore ~A~%~TLookahead ~A~%~TW: ~A~%~TB: ~A to ~A~%~TJ: ~A to ~A"
	  (candidate-score c) 
	  (candidate-la-score c)
	  (candidate-world c)
	  (candidate-original-belief c)
	  (candidate-belief c)
	  (candidate-original-justification c)
	  (candidate-justification c)))

;;;;;
;; candidate
;;
;; a structure that contains all the relevant information for
;; candidate explanations of a belief.
(defstruct (candidate (:print-function print-candidate)
		      (:predicate candidate?))
  original-belief        ;; belief before unification
  original-justification ;; justification before unification
  world                  ;; the home world of belief if it exists
                         ;; or the world that should eventually contain a new belief
                         ;; not necessarily the intended home of the justification
  belief
  justification
  (la-score 0) ;; score based on a lookahead heuristic
  (score 0))
